Private Sub ComboBox1_Change()
Dim ws As Worksheet, sn, i As Long, x0, nr As String
Set ws = Worksheets("ACCEUIL")
With ws
    If .Range("A8") = vbNullString Then nr = 1001: GoTo nextnum
    sn = .Range("A7", .Range("A" & .Rows.Count).End(xlUp))
    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(sn)
            x0 = .Item(CDbl(Split(sn(i, 1), "-")(1)))
        Next
        nr = Application.Max(.keys)
    End With
    nr = nr + 1
nextnum:
End With
If Me.ComboBox1.Value = "NOTES" Then
TextBox1.Text = "NOTES-" & nr
End If
If Me.ComboBox1.Value = "INSTRUCTIONS" Then
TextBox1.Text = "INST-" & nr
End If
If Me.ComboBox1.Value = "PROCEDURES" Then
TextBox1.Text = "PROC-" & nr
End If
If Me.ComboBox1.Value = "CAS D'ESPACES" Then
TextBox1.Text = "CESP-" & nr
End If

ch4.........Archivage physique....4...D
index......index.................1....A
ch9.....Adresse du Document.....6.....F
ch1....Titre du document.......2......B
ch11...DATE....................7......G
ch2....COMMENTAIRE..............3.....C
ch6.....DOOSIER................5......E
ch7....MOT CLE.................8......H

...........................................................
'Rangement d'un document dans un dossier
Sub rangedossier(boite, doc)
Set fso = CreateObject("scripting.filesystemobject")
Set Fichier = fso.getfile(doc)
'MsgBox Fichier.Path
dossier = chemindocuments & "\" & boite.ch4.Value & "\"
fso.copyfile Fichier.Path, dossier & Fichier.Name
Set newfichier = fso.getfile(dossier & Fichier.Name)
boite.ch9 = newfichier.Path
pr: On Error Resume Next
 fso.deletefile Fichier
If Err = 70 Then
erreur.erreurmess = "Le document ( " & Fichier.Name & ") est ouvert. " _
& Chr(10) & "Fermer le et continuer pour finaliser l'opération d'ajout "
erreur.Show
On Error GoTo 0
GoTo pr
End If
dossier = boite.ch4.Value
End Sub
---------------------------------------------------------
ch11...........date

Dim NomFichier  As String
Dim NomDossier  As String
Dim Chemin      As String
Dim iRow As Long
Dim ws As Worksheet
Set ws = Worksheets("ACCEUIL")

'find first empty row in database
iRow = ws.Cells.Find(What:="*", SearchOrder:=xlRows, _
    SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1

Application.DisplayAlerts = False
    
    NomFichier = ch1.Value
    'NomDossier = ch6.Value
    
    NomFichier = NomFichier & "\"
if me.ch6.value="DOS_NOTES" then
NomDossier = ThisWorkbook.Path & "\DOS_NOTES\" & NomFichier & "_" & _ch11 & "\"
elseif me.ch6.Value="DOS_INSTRUCTIONS" then
 NomDossier = ThisWorkbook.Path & "\DOS_INSTRUCTIONS\" & NomFichier & "_" & _ch11 & "\"
elseif me.ch6.Value="DOS_PROCEDURES" then
NomDossier = ThisWorkbook.Path & "\DOS_PROCEDURES\" & NomFichier & "_" & _ch11 & "\"
elseif me.ch6.Value="DOS_CAS_ESPACES" then
NomDossier = ThisWorkbook.Path & "\DOS_CAS_ESPACES\" & NomFichier & "_" & _ch11 & "\"
end if

 Dim FSO As Object
    Dim SourceFileName As String, DestinFileName As String

    Set FSO = CreateObject("Scripting.Filesystemobject")
    SourceFileName = Me.ch9.Value
    DestinFileName = Me.ch6.Value
    FSO.MoveFile Source:=SourceFileName, Destination:=DestinFileName


With ws
'copy the data to the database
.Cells(iRow, 4).Value = Me.ch4.Value
.Cells(iRow, 1).Value = Me.index.Value
.Cells(iRow, 6).Value = Me.ch9.Value
.Cells(iRow, 2).Value = Me.ch1.Value
.Cells(iRow, 7).Value = Me.ch11.Value
.Cells(iRow, 3).Value = Me.ch2.Value
.Cells(iRow, 5).Value = Me.ch6.Value
.Cells(iRow, 8).Value = Me.ch7.Value
End With
MsgBox "Enregistrement Effectué avec Succès", vbOKOnly + vbInformation, "Registration Complete"
Me.ch4.Value
.Cells(iRow, 1).Value = ""
.Cells(iRow, 6).Value = ""
.Cells(iRow, 2).Value = ""
.Cells(iRow, 7).Value =""
.Cells(iRow, 3).Value =""
.Cells(iRow, 5).Value =""
.Cells(iRow, 8).Value =""

Unload saisie
saisie.Show
------------------------------------------------------------------------
pic = ThisWorkbook.path & "\" & Format(Now, "yymmdd hhmmss") & "\"
Sub rangedossier(boite, doc)
Set FSO = CreateObject("scripting.filesystemobject")
Set fichier = FSO.getfile(doc)
'MsgBox Fichier.Path
dossier = chemindocuments & "\" & ch6.Value & "\"
FSO.copyfile fichier.Path, dossier & fichier.Name
Set newfichier = FSO.getfile(dossier & fichier.Name)
boite.ch9 = newfichier.Path
pr: On Error Resume Next
 FSO.deletefile fichier
If Err = 70 Then
erreur.erreurmess = "Le document ( " & fichier.Name & ") est ouvert. " _
& Chr(10) & "Fermer le et continuer pour finaliser l'opération d'ajout "
erreur.Show
On Error GoTo 0
GoTo pr
End If
dossier = Me.ch6.Value
End Sub

ch6
& Format(Now, "yyyy_mm_dd  hmmAM/PM") & "\"
----------------------------------------------------------------------
'copy files into folder
    Dim FSO As Object
    Dim FileName As String
    Dim DestinationPath As String
    Dim fileExtn As String

fileExtn = Me.ch1 & Format(Now, "yymmdd hhmmss") & "\"
textbox.SelectedPath
Application.GetOpenFilename

If Me.ch6.Value = "DOS_NOTES" Then
  Activedocument.SaveAs FileName:= = "E:\BASE_DOCUMENTATIONS_DP\DOS_NOTES\" & fileExtn
      
   
 ElseIf Me.ch6.Value = "DOS_INSTRUCTIONS" Then
   ActiveWorkbook.SaveAs FileName:= = "E:\BASE_DOCUMENTATIONS_DP\DOS_INSTRUCTIONS\" & fileExtn
   
  ElseIf Me.ch6.Value = "DOS_PROCEDURES" Then
   ActiveWorkbook.SaveAs FileName:= = "E:\BASE_DOCUMENTATIONS_DP\DOS_PROCEDURES\" & fileExtn
   
   ElseIf Me.ch6.Value = "DOS_CAS_ESPACES" Then
   ActiveWorkbook.SaveAs FileName:= = "E:\BASE_DOCUMENTATIONS_DP\DOS_CAS_ESPACES\" & fileExtn
 
End If
----------------------------------------------------------------
 c00 = ThisWorkbook.path & "\QR_CODE_FICHIER\QR_" & Txt & ".GIF"

Option Explicit
Sub ParcourirFichier()
    Dim Chemin$, Fichier$, Msg$
    Chemin = "D:\Atelier\"    ' Chemin du repertoire voulu
    If Dir(Chemin, vbDirectory) = vbNullString Then MsgBox Chemin & vbLf & "Chemin inexistant.": Exit Sub
    'Fichier va contenir le Nom du premier Fichier rencontré dans "D:\Atelier"
    Fichier = Dir(fichs)

    'Tant que Fichier est Différent de Vide(Tant qu'il y a un fichier à lire, simplement
    Do While Fichier <> ""
        'On ajoute dans la variable msg le nom du fichier plus un retour de ligne (juste pour cet exemple)
        Msg = Msg & Fichier & vbLf    ' fichier
        Fichier = Dir    ' le fichier suivant...
    Loop
    If Msg <> "" Then
        MsgBox Msg, , "Fichier dans le répertoire " & Chemin
    Else
        MsgBox Chemin & vbLf & "Répertoire vide."
    End If
End Sub
-------------------------------------------------------------------------------------------------
Private Sub LetsMove_Click()
 Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
 Dim newName As String, oldAdressFld As String, NewLocationFld As String
 Dim strExtension As String, objCr, creationDate As String

 oldAdressFld = ch9.text
 'NewLocationFld = NewLocationTextBox.text

 Set mergeObj = CreateObject("Scripting.FileSystemObject")
 
 Set dirObj = mergeObj.GetFolder(oldAdressFld)
 Set filesObj = dirObj.Files

 For Each everyObj In filesObj
    
        If Me.ch6.Value = "DOS_NOTES" Then
        My.Computer.FileSystem.CopyFile(Chemin, "E:\BASE_DOCUMENTATIONS_DP\DOS_NOTES\")
        end if
        If Me.ch6.Value = "DOS_INSTRUCTIONS" Then
        My.Computer.FileSystem.CopyFile(Chemin, "E:\BASE_DOCUMENTATIONS_DP\DOS_INSTRUCTIONS\")
        end if
	If Me.ch6.Value = "DOS_PROCEDURES" Then
        My.Computer.FileSystem.CopyFile(Chemin, "E:\BASE_DOCUMENTATIONS_DP\DOS_PROCEDURES\")
        end if
        If Me.ch6.Value = "DOS_CAS_ESPACES" Then
        My.Computer.FileSystem.CopyFile(Chemin, "E:\BASE_DOCUMENTATIONS_DP\DOS_CAS_ESPACES\")
        end if
  
 Next

End Sub
----------------------------------------
Dim fileName, filePath As String
filePath = ch9.vlue
fileName = Dir(filePath)
Name "C:\data\babar.xls" As "C:\data\old\babar" & " " & Format(Date, "ddmmyyyy") & ".xls"


--------------------------------------------------------
Sub DEPLACE()
Dim dosfichiers As String
Dim dosdestination As String
Dim fso As objet
Dim dos As objet
Dim Fichier As Object

ChDir 
'crée l'objet FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
dosfichiers = ch9.vlue
dosdestination = "E:\BASE_DOCUMENTATIONS_DP\"

'récupère la collection des fichiers
'dans le dossier d'origine
Set dos = fso.GetFolder(dosfichiers)

If Me.ch6.Value = "DOS_NOTES" Then
fso.copyFile dosfichiers & "\" & Fichier.Name, dosdestination & "\DOS_NOTES\" & Fichier.Name
end if
If Me.ch6.Value = "DOS_INSTRUCTIONS" Then
fso.copyFile dosfichiers & "\" & Fichier.Name, dosdestination & "\DOS_INSTRUCTIONS\" & Fichier.Name
end if
If Me.ch6.Value = "DOS_PROCEDURES" Then
fso.copyFile dosfichiers & "\" & Fichier.Name, dosdestination & "\DOS_PROCEDURES\" & Fichier.Name
end if
If Me.ch6.Value = "DOS_CAS_ESPACES" Then
fso.copyFile dosfichiers & "\" & Fichier.Name, dosdestination & "\DOS_CAS_ESPACES\" & Fichier.Name
end if


End Sub
--------------------
Dim dosfichiers As String
Dim dosdestination As String

Dim Fichier As Object

n = 1
Set fso = CreateObject("scripting.filesystemobject")
k = ThisWorkbook.Sheets(1).Cells(n, 1)
While k <> ""
chemin = Left(k, InStrRev(k, "\"))
Set fich = fso.getfile(k)



Wend




ChDir 
'crée l'objet FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
dosfichiers = Me.ch9
dosdestination = "E:\BASE_DOCUMENTATIONS_DP\"

'récupère la collection des fichiers
'dans le dossier d'origine
Set dos = fso.GetFolder(dosfichiers)

If Me.ch6.Value = "DOS_NOTES" Then
fso.copyFile dosfichiers & "\" & Fichier.Name, dosdestination & "\DOS_NOTES\" & Fichier.Name
end if
If Me.ch6.Value = "DOS_INSTRUCTIONS" Then
fso.copyFile dosfichiers & "\" & Fichier.Name, dosdestination & "\DOS_INSTRUCTIONS\" & Fichier.Name
end if
If Me.ch6.Value = "DOS_PROCEDURES" Then
fso.copyFile dosfichiers & "\" & Fichier.Name, dosdestination & "\DOS_PROCEDURES\" & Fichier.Name
end if
If Me.ch6.Value = "DOS_CAS_ESPACES" Then
fso.copyFile dosfichiers & "\" & Fichier.Name, dosdestination & "\DOS_CAS_ESPACES\" & Fichier.Name
end if
------------------------------------------
Sub rangedossier(boite, doc)
Set fso = CreateObject("scripting.filesystemobject")
Set Fichier = fso.getfile(doc)
'MsgBox Fichier.Path
dossier = chemindocuments & "\" & Me.ch6.Value & "\"
fso.copyFile Fichier.Path, dossier & Fichier.Name
Set newfichier = fso.getfile(dossier & Fichier.Name)
Me.ch9 = newfichier.Path
pr: On Error Resume Next
 fso.deletefile Fichier
If Err = 70 Then
erreur.erreurmess = "Le document ( " & Fichier.Name & ") est ouvert. " _
& Chr(10) & "Fermer le et continuer pour finaliser l'opération d'ajout "
erreur.Show
On Error GoTo 0
GoTo pr
End If
dossier = Me.ch6.Value
End Sub
-----------------------
If Me.ch6.Value = "DOS_NOTES" Then
Name fichs & "\" As "E:\BASE_DOCUMENTATIONS_DP\DOS_NOTES\"
End If
If Me.ch6.Value = "DOS_INSTRUCTIONS" Then
Name fichs & "\" As "E:\BASE_DOCUMENTATIONS_DP\DOS_INSTRUCTIONS\"
End If
If Me.ch6.Value = "DOS_PROCEDURES" Then
Name fichs & "\" As "E:\BASE_DOCUMENTATIONS_DP\DOS_PROCEDURES\"
End If
If Me.ch6.Value = "DOS_CAS_ESPACES" Then
Name fichs & "\" As "E:\BASE_DOCUMENTATIONS_DP\DOS_CAS_ESPACES\"
End If


  Dim xdir As String
   Application.ScreenUpdating = False
If Me.ch6.Value = "DOS_NOTES" Then
xdir = "E:\BASE_DOCUMENTATIONS_DP\DOS_NOTES\" & ch9.Value
end if
If Me.ch6.Value = "DOS_INSTRUCTIONS" Then
xdir = "E:\BASE_DOCUMENTATIONS_DP\DOS_INSTRUCTIONS\" & ch9.Value
end if
If Me.ch6.Value = "DOS_PROCEDURES" Then
xdir = "E:\BASE_DOCUMENTATIONS_DP\DOS_PROCEDURES\" & ch9.Value
end if
If Me.ch6.Value = "DOS_CAS_ESPACES" Then
xdir = "E:\BASE_DOCUMENTATIONS_DP\DOS_CAS_ESPACES\" & ch9.Value
end if
 Application.ScreenUpdating = True